home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel0_89.lha / Feel / Modules / eulinda.em < prev    next >
Lisp/Scheme  |  1993-07-03  |  8KB  |  257 lines
  1. ;; A simple Linda implementation
  2. ;; RJB March 92
  3.  
  4. ;; (make-linda-pool)
  5. ;; (linda-out pool tag . values)
  6. ;; (linda-in pool tag . pattern)
  7. ;; (linda-in? pool tag . pattern)
  8. ;; (linda-read pool tag . pattern)
  9. ;; (linda-read? pool tag . pattern)
  10. ;; (linda-eval fun . args)
  11.  
  12. ;; linda-in? and linda-read? are non-blocking versions of linda-in
  13. ;; and linda-read, returning () if no matching tuple, t otherwise.
  14.  
  15. ;; the pattern (? var) matches anything, and assigns that value to var
  16. ;; the pattern ? matches anything, and discards the value
  17. ;; tags, and any other patterns are matched literally
  18.  
  19. ;; e.g.
  20. ;; (setq pp (make-linda-pool))
  21. ;; (linda-out pp 'foo 1 2)
  22. ;; (linda-read pp 'foo ? (? x))      setqs x to 2
  23. ;; (linda-read? pp 'foo 1 2 3)       returns ()
  24. ;; (linda-read pp 'foo 1 2 3)        suspends
  25.  
  26. (defmodule eulinda 
  27.   ((rename ((lock open-lock)
  28.         (unlock close-lock))
  29.        eulisp0) )
  30.    ()
  31.  
  32.   (deflocal trace-linda? ())
  33.  
  34.   (defun tril (x) (setq trace-linda? x))
  35.  
  36.   (defstruct linda-pool ()
  37.     ((lock initform (make <lock>)
  38.        accessor linda-pool-lock)
  39.      (tuple-table initform (make-linda-tuple-table)
  40.           accessor linda-pool-tuple-table))
  41.     constructor make-linda-pool)
  42.  
  43.   (defun print-linda-pool (pool)
  44.     (format t "#< ")
  45.     (map-table
  46.      (lambda (k v) (format t "~a " v))
  47.      (linda-pool-tuple-table pool))
  48.     (format t ">~%"))
  49.  
  50.   (defun tidy-pattern (pat)
  51.     (cond ((null pat) ())
  52.       ((eq (car pat) '?)
  53.        (cons '? (tidy-pattern (cdr pat))))
  54.       ((and (consp (car pat))
  55.         (eq (caar pat) '?))
  56.        (cons '? (tidy-pattern (cdr pat))))
  57.       (t (cons (car pat) (tidy-pattern (cdr pat))))))
  58.  
  59.   (defun do-setqs-aux (pattern n)
  60.     (cond ((null pattern) ())
  61.       ((and (consp (car pattern))
  62.         (eq (caar pattern) '?))
  63.        (cons `(setq ,(cadar pattern) (vector-ref *tuple* ,n))
  64.          (do-setqs-aux (cdr pattern) (+ n 1))))
  65.       (t (do-setqs-aux (cdr pattern) (+ n 1)))))
  66.  
  67.   (defun do-setqs (pattern)
  68.       (do-setqs-aux pattern 0))
  69.  
  70.   (defmacro linda-in (pool tag . pattern)
  71.     `(let ((*tuple* (convert (linda-tuple-value
  72.                   (linda-in-tuple ,pool ,tag
  73.                           ,@(tidy-pattern pattern)))
  74.                  <vector>)))
  75.        ,@(do-setqs pattern)
  76.        *tuple*))
  77.  
  78.   (defun linda-in-tuple (pool tag . pattern)
  79.     (when trace-linda? (format t ";; in-ing ~a ~a~%" tag pattern))
  80.     (let ((val (linda-in/read pool tag (tuple tag pattern) in-match)))
  81.       (when trace-linda?
  82.     (format t ";; in'd ~a~%" val))
  83.       val))
  84.  
  85.   (defmacro linda-in? (pool tag . pattern)
  86.     `(let ((*result* (linda-in?-tuple ,pool ,tag
  87.                       ,@(tidy-pattern pattern))))
  88.        (if (null *result*)
  89.        ()
  90.        (let ((*tuple* (convert (linda-tuple-value *result*) <vector>)))
  91.          ,@(do-setqs pattern)
  92.          t))))
  93.  
  94.   (defun linda-in?-tuple (pool tag . pattern)
  95.     (when trace-linda? (format t ";; in?-ing ~a ~a~%" tag pattern))
  96.     (let ((val (linda-in/read? pool tag (tuple tag pattern) in-match)))
  97.       (when trace-linda?
  98.         (format t ";; in?'d ~a~%" val))
  99.       val))
  100.  
  101.   (defmacro linda-read (pool tag . pattern)
  102.     `(let ((*tuple* (convert (linda-tuple-value
  103.                   (linda-read-tuple ,pool ,tag
  104.                  ,@(tidy-pattern pattern)))
  105.                  <vector>)))
  106.        ,@(do-setqs pattern)
  107.        *tuple*))
  108.  
  109.   (defun linda-read-tuple (pool tag . pattern)
  110.     (when trace-linda? (format t ";; reading ~a ~a~%" tag pattern))
  111.     (let ((val (linda-in/read pool tag (tuple tag pattern) read-match)))
  112.       (when trace-linda?
  113.     (format t ";; read ~a~%" val))
  114.       val))
  115.  
  116.   (defmacro linda-read? (pool tag . pattern)
  117.     `(let ((*result* (linda-read?-tuple ,pool ,tag
  118.                     ,@(tidy-pattern pattern))))
  119.        (if (null *result*)
  120.            ()
  121.            (let ((*tuple* (convert (linda-tuple-value *result*) <vector>)))
  122.              ,@(do-setqs pattern)
  123.              t))))
  124.  
  125.   (defun linda-read?-tuple (pool tag . pattern)
  126.     (when trace-linda? (format t ";; read?-ing ~a ~a~%" tag pattern))
  127.     (let ((val (linda-in/read? pool tag (tuple tag pattern) read-match)))
  128.       (when trace-linda?
  129.         (format t ";; read?'d ~a~%" val))
  130.       val))
  131.  
  132.   (defun linda-in/read (pool tag pattern matchfn)
  133.     (let ((lock (linda-pool-lock pool)))
  134.       (open-lock lock)
  135.       (let ((match (matchfn pool tag pattern)))
  136.     (close-lock lock)
  137.     (if (null match)
  138.         (progn
  139.           (when trace-linda?
  140.         (format t ";; suspending~%"))
  141.           (thread-reschedule)
  142.           (when trace-linda?
  143.         (format t ";; retrying ~a ~a~%" tag
  144.             (linda-tuple-value pattern)))
  145.           (linda-in/read pool tag pattern matchfn))
  146.         match))))
  147.  
  148.   (defun linda-in/read? (pool tag pattern matchfn)
  149.     (let ((lock (linda-pool-lock pool)))
  150.       (open-lock lock)
  151.       (let ((match (matchfn pool tag pattern)))
  152.     (close-lock lock)
  153.     (if (null match)
  154.         ()
  155.         match))))
  156.  
  157.   (defun linda-out (pool tag . rest)
  158.     (when trace-linda? (format t ";; out ~a ~a~%" tag rest))
  159.     (let ((lock (linda-pool-lock pool))
  160.       (tup (tuple tag rest)))
  161.       (open-lock lock)
  162.       (linda-out-tuple pool tag tup)
  163.       (close-lock lock)
  164.       (thread-reschedule)
  165.       tup))
  166.  
  167.   (defun make-linda-tuple-table ()
  168.     (make-table eq))
  169.  
  170.   (defstruct linda-tuple ()
  171.     ((tag initarg tag
  172.       reader linda-tuple-tag)
  173.      (value initarg value
  174.         reader linda-tuple-value))
  175.     constructor (tuple tag value))
  176.  
  177.   (defmethod generic-write ((lt linda-tuple) s)
  178.     (format s "#<linda-tuple: ~a ~a>"
  179.         (linda-tuple-tag lt)
  180.         (linda-tuple-value lt)))
  181.  
  182.   (defmethod generic-prin ((lt linda-tuple) s)
  183.     (format s "#<linda-tuple: ~a ~a>"
  184.             (linda-tuple-tag lt)
  185.             (linda-tuple-value lt)))
  186.  
  187.   (defun delete1 (obj lis)
  188.     (labels ((aux (end lst)
  189.           (cond ((null lst)
  190.              nil)
  191.             ((eq obj (car lst))
  192.              (aux end (cdr lst)))
  193.             (t 
  194.              ((setter cdr) end (cons (car lst) nil))
  195.              (aux (cdr end) (cdr lst))))))
  196.         (if (null lis) nil
  197.           (if (eq (car lis) obj) 
  198.           (mapcar (lambda (x) x) lis)
  199.         (progn (let ((first (cons (car lis) nil)))
  200.              (aux first (cdr lis))
  201.              first))))))
  202.              
  203.                
  204.  
  205.   (defun in-match (pool tag pattern-tuple)
  206.     (let* ((table (linda-pool-tuple-table pool))
  207.        (vallist (table-ref table tag))
  208.        (val (match-in-list (linda-tuple-value pattern-tuple) vallist)))
  209.       (unless (null val)
  210.     ((setter table-ref) table tag (delete1 val vallist)))
  211.       val))
  212.  
  213.   (defun read-match (pool tag pattern-tuple)
  214.     (let* ((table (linda-pool-tuple-table pool))
  215.            (vallist (table-ref table tag)))
  216.       (match-in-list (linda-tuple-value pattern-tuple) vallist)))
  217.  
  218.   (defun match-in-list (pat vallist)
  219.     (cond ((null vallist) ())
  220.       ((matchit pat (linda-tuple-value (car vallist))) (car vallist))
  221.       (t (match-in-list pat (cdr vallist)))))
  222.  
  223.   (defun matchit (pat val)
  224.     (cond ((null pat) t)
  225.       ((null val) ())
  226.       ((equal (car pat) (car val))
  227.        (matchit (cdr pat) (cdr val)))
  228.       ((eq (car pat) '?)
  229.        (matchit (cdr pat) (cdr val)))
  230.       (t ())))
  231.  
  232.   ; putting tuple at end allows weak fairness on tuple selection
  233.   ; for a given tag
  234.   (defun linda-out-tuple (pool tag tuple)
  235.     (let* ((table (linda-pool-tuple-table pool))
  236.            (val (table-ref table tag)))
  237.       ((setter table-ref) table tag (nconc val (list tuple)))
  238.       tuple))
  239.  
  240.   (defun linda-eval (fun . args)
  241.     (when trace-linda?
  242.       (format t ";; eval ~a~%" fun))
  243.     (apply thread-start (make-thread fun) args))
  244.  
  245.   ; a convenient fiddle
  246.   (defconstant ? '?)
  247.  
  248.   (export make-linda-pool linda-in linda-read linda-out linda-eval)
  249.   (export linda-in? linda-read?)
  250.   (export linda-in-tuple linda-read-tuple)
  251.   (export linda-in?-tuple linda-read?-tuple)
  252.   (export linda-tuple-value ?)
  253.  
  254.   (export print-linda-pool tril)
  255.  
  256. )
  257.